﻿{-# OPTIONS_GHC -XTemplateHaskell -XNoMonomorphismRestriction #-}
module Text.XML.Xmlable.XmlableTH(mkXmlableFieldsCount, deriveXmlable, deriveXmlables, flipr0, flipr1, comp1, parseEs0) where

import qualified Language.Haskell.TH.Syntax as TH
import Language.Haskell.TH
import Data.Maybe
import Control.Monad
import Control.Monad.Error
import Control.Monad.State
import Control.Arrow(first, second)
import Data.Function(on)
import Data.List(sortBy, nub)
import Data.Monoid
import qualified Data.Map as Map
import Text.XML.Xmlable.Xmlable
import Text.XML.Xmlable.ParseEsTH
import Data.Function.FliprTH


data DT = DT
newtype NT = NT Int

flipr0 = id
flipr1 = flip
comp1 = (.)
parseEs0 = return

mkXmlableFieldsCount n = liftM2 (++) (sequence $ mkFliprs n) $ defParseEsN n

instance TH.Lift XmlDesc where
    lift (XtElem s) = appE (conE 'XtElem) (TH.lift s)
    --'
    lift (XtAttr s) = appE (conE 'XtAttr) (TH.lift s)
    --'
    lift XtVal = return $ ConE 'XtVal
    --'

instance TH.Lift XmlDescCons where
    lift (XdcElem s fs) = appE (appE (conE 'XdcElem) (TH.lift s)) (TH.lift fs)
    --'
    lift (XdcAttr s) = appE (conE 'XdcAttr) (TH.lift s)
    --'
    lift XdcVal = return $ ConE 'XdcVal
    --'
instance (TH.Lift a, TH.Lift b) => TH.Lift (Map.Map a b) where
    lift = appE [| Map.fromList |] . TH.lift . Map.toList
    
parseErr lst tn cns = bindX (msum $ zipWith (\l c -> bindX l $ "Error for parsing constructor " ++ c) lst cns) $ "error in TH (Type: " ++ tn ++ ")"

deriveXmlables :: Bool -> (XmlEnv -> XmlEnv) -> [Name] -> Q [Dec]
deriveXmlables isReport f = liftM (nub . concat) . mapM (deriveXmlable isReport f)

deriveXmlable :: Bool -> (XmlEnv -> XmlEnv) -> Name -> Q [Dec]
deriveXmlable isReport f t = do
    TyConI def <- reify t
    (cxt, ps, cs, isdata) <- return $ case def of
        (DataD cxt _ ps cs _) -> (cxt, ps, cs, True)
        (NewtypeD cxt _ ps c _) -> (cxt, ps, [c], False)
        
    check cxt ps cs
    
    lst0 <- return $ map (\c -> case c of
            NormalC cn as -> getData cn $ map (\(_, t) -> ("", t)) as
            RecC cn as -> getData cn $ map (\(a, _, t) -> (nameBase a, t)) as
        ) cs
    lst <- listE $ map (
            (\(_, n, e, cE) -> [|setEnv' e $ parseElem $(varE $ mkName $ "parseEs" ++ show n) $(cE)|]) . 
            (\(cname, n, env) -> (cname, n, first (liftM elemAttrUp) env, flipCons (xdcFields $ fromJust $ fst env) cname))
        ) lst0
    
    dd <- newName "dd"
    x <- newName "x"
    tox <- lamE [varP dd, varP x] $ caseE (varE x) $ map (\(cname, n, env) -> do
            names <- mapM (const $ newName "z") [1..n]
            fs <- listE $ map (\name -> [| flip toXml $(varE name) |]) names
            body <- [| elemBE $(varE dd) env $(return fs) |]
            match (conP cname (map varP names)) (normalB [| elemBE $(varE dd) env $(return fs) |]) []
        ) lst0

    tn <- return $ show t
    cns <- return $ map (\(cn, _, _) -> nameBase cn) lst0
    dt <- if isdata then [d|
            instance Xmlable DT where
                parse = parseErr $(return lst) tn cns
                toXml = $(return tox)
        |] else [d|
            instance Xmlable NT where
                parse = parseErr $(return lst) tn cns
                toXml = $(return tox)
        |]
    dt' <- case dt of
        [InstanceD xs1 (AppT xt (ConT _)) xs2] -> return [InstanceD xs1 (AppT xt (ConT t)) xs2]
        d -> report True ("Invalid instance: " ++ show d) >> return []
    
    when isReport $ report False (pprint dt')
    return dt'
    where
        isConsNR (NormalC _ _) = True; isConsNR (RecC _ _) = True; isConsNR _ = False
        isPlainTV (PlainTV _) = True; isPlainTV _ = False
                
        check cxt ps cs = zipWithM (flip when . report True) [
                "Some constructors are not in Normal or Record form"
                , "Some type parameters are not Plain (i.e. Kinded)"
                , "Some type parameters are not Xmlable"
            ] [
                any (not . isConsNR) cs
                , any (not . isPlainTV) ps
                , any (`elem` [t | ClassP n ts <- cxt, VarT t <- ts, n == ''Xmlable]) [n | PlainTV n <- ps]
            ]
    
        getData :: Name -> [(String, Type)] -> (Name, Int, XmlEnv)
{-
type XmlDescConsM = Maybe (XmlDesc, [XmlDesc])
type Namespaces = [(String, String)]
type XmlEnv = (XmlDescConsM, Namespaces)
-}
        getData cn as = (cn, length as, f (
                Just (XdcElem (nameBase cn) $ map (\(name, t) -> getEnv name $ isSimple t) as), 
                Map.fromList [("ns0", ns), ("", ns)]
            ))
            where
                ns = "http://haskell.org/" ++ map (\c -> if c == '.' then '/' else c) (fromMaybe "" $ nameModule cn)
                getEnv a b = defDesc
                    where
                        defDesc
                            | b && null a   = XtVal
                            | b             = XtAttr a
                            | otherwise     = XtElem a
                isSimple tt = show tt `elem` (simples ++ map ((++")") . ("AppT (ConT Data.Maybe.Maybe) (" ++)) simples)
                    where
                        simples = map show [ConT ''Int, ConT ''Integer, ConT ''String, ConT ''Float, ConT ''Double, ConT ''Bool,
                                ConT ''Char, AppT ListT $ ConT ''Char]
        flipCons :: [XmlDesc] -> Name -> ExpQ
        flipCons as = appE (fliprs $ map (isAttr) as) . conE

        elemAttrUp (XdcElem n ds) = XdcElem n $ sortBy (compare `on` (not . isAttr)) ds
        elemAttrUp x = error $ "Invalid param in elemAttrUp: " ++ show x
{-
msum [
            setEnv "X2" [XmlDesc XtAttr "f21", XmlDesc XtAttr "f22"] $ parseElem parseEs2 X2
            , setEnv "X22" [XmlDesc XtAttr "f231", XmlDesc XtAttr "f232"] $ parseElem parseEs2 X22
            , setEnv "X23" [XmlDesc XtAttr "f231", XmlDesc XtAttr "f232", XmlDesc XtAttr "f233"] $ parseElem parseEs3 X23
            , setEnv "X24" [XmlDesc XtAttr "f241", XmlDesc XtAttr "f242", XmlDesc XtAttr "f243"] $ parseElem parseEs3 X24
            , setEnv "X25" [] $ parseElem parseEs2 X25
        ]
-}

{-
fliprs: [True, False, False, True, False, True, False] -> [0,2,3] -> [| ((flipr3.).) . (flipr2.) . flipr0 |]
        [False, False] -> [] -> [| id |]
-}
fliprs bs
    | null $ dropWhile (==0) counts = [| id |]
    | otherwise = foldl1 (\res x -> infixE (Just x) dot (Just res)) $ map (uncurry getFlip) $ dropWhile ((==0).fst) $ zip counts [0..]
    where
        counts = reverse $ snd $ foldl (\(n,xs) b -> if b then (n,n:xs) else (n+1,xs)) (0,[]) bs
        dot = [|(.)|]
        getFlip nf  = (iterate (\x -> infixE (Just x) dot Nothing) (varE $ mkName $ "flipr" ++ show nf) !!)

elemBE :: Maybe XmlDesc -> XmlEnv -> [Maybe XmlDesc -> [Xml]] -> [Xml]
elemBE d env fs = ElemB (xdName $ fromMaybe xd d) mempty : joinChilds fs (map Just $ xdcFields xdc) ++ [ElemE]
    where
        joinChilds fs = concatMap (uncurry ($)) . sortBy (compare `on` (not . isAttr . fromJust . snd)). zip fs
        xdc = fromJust $ fst env
        xd = xdc2xd xdc

